home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Libris Britannia 4
/
science library(b).zip
/
science library(b)
/
PROGRAMM
/
DB_CLIPP
/
0828.ZIP
/
DPROG131.ZIP
/
PROGFORM.TXT
< prev
next >
Wrap
Text File
|
1988-08-07
|
45KB
|
1,915 lines
*%%OPENFROM,SYSNAME
*%%IF,PRG
*%%DOCUMENT,PRG,Main Program
SET ESCAPE OFF
SET STATUS OFF
SET TALK OFF
SET ECHO OFF
SET BELL OFF
SET HEADING OFF
SET SAFETY OFF
SET DEVICE TO SCREEN
CLEAR
*%%SETPROC
PUBLIC DBVersion, UserScrn
*%%DBVERSION
*%%MMLOAD
SELECT A
USE &MainFile
DO IND WITH MainFile, IndxFile, IndxExpr, "ENSURE"
SET FILTER TO .T.
*%%IF,PUB
DO PUB
*%%ENDIF
*%%MMINIT
CLEAR GETS
MHH=MH1
P=0
DO WHILE .T.
*%%MMSHOW
@ 24,0
@ 2,3 SAY DTOC(DATE())
@ 2,69 SAY Time()
@p+5,C GET MHH
CLEAR GETS
DO WHIL .T.
o=0
DO WHIL o<=0
o=INKE()
ENDD
t=0
@p+5,C SAY MHH
DO CASE
CASE o=5
p=p-1
CASE o=24
p=p+1
CASE o=13
t=P+1
OTHE
t=AT(UPPE(CHR(o)),VK)
p=IIF(t=0,p,t-1)
ENDC
p=IIF(p<0,NOP,p)
p=IIF(p>NOP,0,p)
DO CASE
CASE P=0
@ 5,C GET MH1
MHH=MH1
CASE P=1
@ 6,C GET MH2
MHH=MH2
CASE P=2
@ 7,C GET MH3
MHH=MH3
CASE P=3
@ 8,C GET MH4
MHH=MH4
CASE P=4
@ 9,C GET MH5
MHH=MH5
CASE P=5
@ 10,C GET MH6
MHH=MH6
CASE P=6
@ 11,C GET MH7
MHH=MH7
CASE P=7
@ 12,C GET MH8
MHH=MH8
CASE P=8
@ 13,C GET MH9
MHH=MH9
CASE P=9
@ 14,C GET MH10
MHH=MH10
ENDC
CLEAR GETS
IF t>0
MH_Function=SUBS(VK,t,1)
EXIT
ENDI
ENDD
DO CASE
*%%IF,ADD
CASE MH_Function="A"
DO ADD
LOOP
*%%ENDIF
*%%IF,UPD
CASE MH_Function="U"
IF RECCOUNT()=0
*%%IF,PRG
DO WAI WITH 24, 0, "File empty, request denied. "
*%%ENDIF
LOOP
ENDIF
DO UPD
LOOP
*%%ENDIF
*%%IF,RPT
CASE MH_Function="R"
DO RPT
GO TOP
LOOP
*%%ENDIF
*%%IF,MM
CASE MH_Function="M"
DO MM
GO TOP
LOOP
*%%ENDIF
*%%IF,LAB
CASE MH_Function="L"
DO LAB
GO TOP
LOOP
*%%ENDIF
*%%IF,HLP
CASE MH_Function="H"
DO HLP WITH 1
LOOP
*%%ENDIF
CASE MH_Function="P"
@24,0
@24,0 SAY "Delete all marked records"
STORE "N" TO MH_Ans
@24,30 GET MH_Ans
READ
IF UPPER(MH_Ans) = "Y"
PACK
GO TOP
ENDIF
RELEASE MH_Ans
LOOP
CASE MH_Function="I"
DO IND WITH MainFile, IndxFile, IndxExpr, "REINDEX"
LOOP
CASE MH_Function="Q"
RELEASE MH_Function
*%%IF,REL
DO REL
*%%ENDIF
CLOSE DATABASES
CLOSE PROC
CLEAR
QUIT
*%%IF,SRT
CASE MH_Function="S"
DO DPSORT
*%%SETPROC
USE &MainFile
DO IND WITH MainFile, IndxFile, IndxExpr, "ENSURE"
LOOP
*%%ENDIF
CASE MH_Function="D"
RELEASE MH_Function
*%%IF,REL
DO REL
*%%ENDIF
CLOSE DATABASES
CLOSE PROC
CLEAR
SET ESCAPE ON
SET STATUS ON
SET TALK ON
SET BELL ON
SET HEADING ON
SET SAFETY ON
RETURN
ENDCASE
ENDDO
RETURN
*%%ENDIF
*%%IF,PRG
*%%DOCUMENT,WAI,Wait / Message routine
PROCEDURE WAI
PARA y, x, msg
PRIV dummy
dummy=" "
SET INTE OFF
@Y,X
@Y,X SAY msg+" Press any key to continue..." GET dummy
READ
SET INTE ON
@Y,X
RETU
*%%ENDIF
*%%IF,PRG
*%%DOCUMENT,BMU,Parameterized bar menu routine
PROCEDURE BMU
PARA m,s,L,R,p,C
* parameters:
* in: m(menustr),L(len 1 opt),R(row);
* out: p (pos. in m, global for continuity), C (choice char)
PRIV g,t,o,sc
sc=" "+s
E=LEN(M)/L-1
g=SUBS(m,p*L+1,L)
@r,0 SAY m
@r,p*L GET g
CLEA GETS
t=0
c=" "
DO WHIL c=" "
o=0
DO WHIL o<=0
o=INKE()
ENDD
t=0
DO CASE
CASE o=4.OR.o=32
p=p+1
CASE o=19
p=p-1
CASE o=13
t=p+1
OTHE
t=AT(UPPE(CHR(o)),s)
p=IIF(t=0,p,t-1)
ENDC
p=IIF(p<0,E,p)
p=IIF(p>E,0,p)
C=SUBS(sc,t+1,1)
g=SUBS(m,p*L+1,L)
@r,0 SAY m
@r,p*L GET g
CLEA GETS
ENDD
RETU
*%%ENDIF
*%%IF,FMT
*%%DOCUMENT,FMT,Screen Format File
PROCEDURE FMT
*%%FMT
RETURN
*%%ENDIF
*%%IF,PUB
*%%DOCUMENT,PUB,Define Public Fields
PROCEDURE PUB
PUBLIC Clipper
*%%PUB
RETURN
*%%ENDIF
*%%IF,CAL
*%%DOCUMENT,CAL,Calculate and display Calculated fields
PROCEDURE CAL
PARAMETERS Updating
*%%CAL
RETURN
*%%ENDIF
*%%IF,INI
*%%DOCUMENT,INI,Initialize memory fields from Init or empty
PROCEDURE INI
*%%INI
RETURN
*%%ENDIF
*%%IF,STO
*%%DOCUMENT,STO,Store file fields to memory variables
PROCEDURE STO
*%%STO
RETURN
*%%ENDIF
*%%IF,REP
*%%DOCUMENT,REP,Replace file fields with memory variables
PROCEDURE REP
*%%REP
RETURN
*%%ENDIF
*%%IF,REL
*%%DOCUMENT,REL,Release Memory variables
PROCEDURE REL
*%%REL
RETURN
*%%ENDIF
*%%IF,ADD
*%%DOCUMENT,ADD,Add New records to file
PROCEDURE ADD
STORE " " TO MH_Wait
IF "DB3+" $ DBVersion
CALL &UserScrn
ELSE
CLEAR
DO DB3
ENDIF
DO WHILE .T.
*%%IF,INI
DO INI
*%%ENDIF
*%%IF,FMT
DO FMT
*%%ENDIF
@24,0
@24,0 SAY "Press Ctrl-W without entering data to exit"
READ
*%%ADD
*%%IF,VAL
DO VAL
*%%ENDIF
@24,0
APPEND BLANK
*%%IF,CAL
DO CAL WITH "ALL"
*%%ENDIF
*%%IF,REP
DO REP
*%%ENDIF
*%%IF,PRG
DO WAI WITH 24,0,""
*%%ENDIF
ELSE
EXIT
ENDIF
ENDDO
RELEASE MH_Wait
RETURN
*%%ENDIF
*%%IF,UPD
*%%DOCUMENT,UPD,Search,Update,Edit,Find,Print,Examine file
PROCEDURE UPD
PRIVATE MH_Function, MH_Answer
STORE "N" TO MH_Function
STORE "N" TO MH_Answer
STORE SPACE(65) TO MH_Filt
IF "DB3+" $ DBVersion
CALL &UserScrn
ELSE
CLEAR
DO DB3
ENDIF
DO WHILE .T.
*%%IF,STO
DO STO
*%%ENDIF
*%%IF,DIS
DO DIS
*%%ENDIF
*%%IF,CAL
DO CAL WITH "VIRTUAL"
*%%ENDIF
IF LEN(TRIM(MH_Filt)) = 0
@24,55 SAY " "
ELSE
@24,55 SAY "FILT"
ENDIF
IF Deleted()
@24,60 SAY "DEL"
ELSE
@24,60 SAY " "
ENDIF
@24,65 SAY Ltrim(Str(RECNO()))+"/"+Ltrim(STR(RECCOUNT()))+" "
MH_Lcho=0
DO BMU WITH "Next Prev Top Bot Quit Edit Set List Find Help Del ","NPTBQESLFHD",5,24,MH_Lcho,MH_Function
@24,0 SAY SPACE(55)
DO CASE
CASE UPPER(MH_Function) = "N"
IF .NOT. EOF()
Skip 1
IF EOF()
GO BOTT
ENDIF
ENDIF
LOOP
CASE UPPER(MH_Function) = "P"
IF .NOT. BOF()
SKIP -1
IF BOF()
GO TOP
ENDIF
ENDIF
LOOP
CASE UPPER(MH_Function) = "E"
*%%IF,STO
DO STO
*%%ENDIF
*%%IF,FMT
DO FMT
*%%ENDIF
READ
*%%IF,VAL
DO VAL
*%%ENDIF
*%%IF,CAL
DO CAL WITH "ALL"
*%%ENDIF
*%%IF,REP
DO REP
*%%ENDIF
LOOP
CASE UPPER(MH_Function) = "T"
GOTO TOP
LOOP
CASE UPPER(MH_Function) = "B"
GOTO BOTTOM
LOOP
CASE UPPER(MH_Function) = "D"
STORE "N" TO MH_Answer
@24,0
IF DELETED()
@24,0 SAY "Recall this record?"
ELSE
@24,0 SAY "Delete this record?"
ENDIF
@24,22 GET MH_Answer
READ
IF UPPER(MH_Answer) = "Y"
IF DELETED()
RECALL
ELSE
DELETE
ENDIF
ENDIF
LOOP
CASE UPPER(MH_Function) = "S"
STORE "N" TO MH_Answer
STORE MH_Filt TO MH_FiltH
@24,0
@24,0 SAY "FILTER: "
@24,9 GET MH_Filt
READ
@24,0
IF MH_Filt <> MH_FiltH
IF LEN(TRIM(MH_Filt))<>0
IF IIF(Clipper,.F.,TYPE(MH_Filt)<>"L")
*%%IF,PRG
DO Wai WITH 24,0,"Filter expression defective, not usable. "
*%%ENDIF
MH_Filt=MH_FiltH
LOOP
ENDIF
SET FILTER TO &MH_Filt
ELSE
SET FILTER TO .T.
ENDIF
GOTO TOP
IF EOF()
*%%IF,PRG
DO WAI WITH 24,0, "Nothing matches filter! "
*%%ENDIF
ENDIF
ENDIF
LOOP
*%%IF,FND
CASE UPPER(MH_Function) = "F"
DO FND
LOOP
*%%ENDIF
CASE UPPER(MH_Function) = "Q"
EXIT
CASE UPPER(MH_Function) = "L"
*%%IF,3PLUS
ON ERROR DO WAI WITH 24,0,"FIX PRINTER!!! "
*%%ENDIF
SET DEVICE TO PRINT
*%%IF,DIS
DO DIS
*%%ENDIF
SET DEVICE TO SCREEN
*%%IF,3PLUS
ON ERROR
*%%ENDIF
LOOP
*%%IF,HLP
CASE UPPER(MH_Function)="H"
DO HLP WITH 2
IF "DB3+" $ DBVersion
CALL &UserScrn
ELSE
CLEAR
DO DB3
ENDIF
LOOP
*%%ENDIF
ENDCASE
ENDDO
SET FILTER TO .T.
RETURN
*%%ENDIF
*%%IF,DIS
*%%DOCUMENT,DIS,Display-only Format file
PROCEDURE DIS
*%%DIS
RETURN
*%%ENDIF
*%%IF,FND
*%%DOCUMENT,FND,Find record by key routine
PROCEDURE FND
IF .NOT. Indexed
*%%IF,PRG
DO WAI WITH 24, 0, "Database is not indexed. Set a filter. "
*%%ENDIF
RETURN
ENDIF
PRIVATE MH_Find, MH_Answer, MH_Rec
@24,0
@24,0 SAY "Enter data to find in open fields"
*%%FND
IF LEN(TRIM(MH_Find)) # 0
STORE RECNO() TO MH_Rec
SEEK MH_Find
IF EOF()
GOTO MH_Rec
*%%IF,PRG
DO WAI WITH 24, 0, "Record Not Found. "
*%%ENDIF
ENDIF
ENDIF
@24,0
RETURN
*%%ENDIF
*%%IF,RPT
*%%DOCUMENT,RPT,Report module
PROCEDURE RPT
STORE .N. TO MH_Prt
STORE .Y. TO MH_Con
STORE .N. TO MH_Disk
STORE " " TO MH_Frm
STORE ".T."+SPACE(73) TO MH_Cri
STORE " " TO MH_DFname
IF "DB3+"$DBVersion
*%%IF,3PLUS
CALL DPOUT
*%%ENDIF
ELSE
CLEAR
DO DPO
ENDIF
@5,22 SAY MH_Prt
@6,22 SAY MH_Con
@7,22 SAY MH_Disk
@7,42 SAY MH_DFname
@9,15 SAY MH_Frm
DO WHILE .T.
@5,22 GET MH_Prt PICTURE "L"
@6,22 GET MH_Con PICTURE "L"
@7,22 GET MH_Disk PICTURE "L"
@7,42 GET MH_Dfname PICTURE "!!!!!!!!!!!!!!"
@9,15 GET MH_Frm PICTURE "!!!!!!!!"
READ
@24,0
IF MH_Prt .AND. MH_Con
@24,0 SAY "You must only specify one output device"
LOOP
ENDIF
IF MH_Prt .AND. MH_Disk
@24,0 SAY "You must only specify one output device"
LOOP
ENDIF
IF MH_Con .AND. MH_Disk
@24,0 SAY "You must only specify one output device"
LOOP
ENDIF
IF MH_Disk .AND. MH_Dfname = " "
@24,0 SAY "You must specify a disk file name"
LOOP
ENDIF
IF MH_Frm = " "
@24,0 SAY "You must enter a sort name or 'NOSORT'"
LOOP
ENDIF
EXIT
ENDDO
IF MH_Frm = "NOSORT "
STORE .F. TO MH_NdxL
ELSE
IF .NOT.(FILE("DPSORT.DBF") .AND. FILE("DPSORT."+IndxExt))
*%%IF,PRG
DO WAI WITH 24,0,"DPSORT files not found. "
*%%ENDIF
RETURN
ENDIF
SELE I
USE DPSORT INDEX DPSORT
SEEK MH_Frm
IF EOF()
*%%IF,PRG
DO Wai WITH 24,0, "Sort name not on selection file (DPSORT.DBF). "
*%%ENDIF
SELE A
RETURN
ENDIF
STORE SORTCRI TO MH_Cri
STORE SORTNDX TO MH_NDX
STORE SORTFRM TO MH_FRM
STORE .F. TO MH_NdxL
MH_Srt="*"
SortOk=.F.
DO SortChk WITH MH_Srt, MH_NdxL, SortOk
IF .NOT. SortOk
*%%IF,PRG
DO WAI WITH 24,0,"Unknown Sort Field, or Field Type not C,D,N. "
*%%ENDIF
RETURN
ENDIF
ENDIF
@16,13 GET MH_Frm
@19,2 GET MH_Cri
READ
DO WHILE LEN(TRIM(MH_Frm)) = 0
@24,0 SAY "You must specify a form for REPORTs and LABELS"
@16,13 GET MH_Frm
READ
ENDDO
@24,0
DO WHILE IIF(Clipper,.F.,TYPE(MH_Cri)<>"L")
@24,0 SAY "Criteria NOT a legal expression"
@19,2 GET MH_Cri
READ
ENDDO
@24,0
STORE TRIM(MH_Frm)+".FRM" TO MH_work
IF .NOT. FILE(MH_Work)
*%%IF,PRG
DO WAI WITH 24,0,"REPORT FORM "+TRIM(MH_Frm)+" not found. "
*%%ENDIF
RETURN
ENDIF
IF MH_NdxL
@24,0
@24,0 SAY "SELECTING/SORTING DATA! PLEASE WAIT . . . "
IF MH_Cri=SPACE(76)
STORE ".T."+SPACE(73) TO MH_Cri
ENDIF
IF RECCOUNT()>1
SORT TO &MH_NDX ON &MH_SRT FOR &MH_Cri
ELSE
COPY TO &MH_NDX FOR &MH_Cri
ENDIF
SELE J
USE &MH_NDX
ELSE
@24,0
@24,0 SAY "Using Unsorted File"
ENDIF
@24,0
@24,0 SAY "PRODUCING OUTPUT. PLEASE WAIT . . . "
DO CASE
CASE MH_Con
REPORT FORM &MH_Frm FOR &MH_Cri
CASE MH_Prt
SET CONSOLE OFF
REPORT FORM &MH_Frm TO PRINT FOR &MH_Cri
SET CONSOLE ON
CASE MH_Disk
SET CONSOLE OFF
SET ALTERNATE TO &MH_Dfname
SET ALTERNATE ON
REPORT FORM &MH_Frm FOR &MH_Cri
SET ALTERNATE OFF
CLOSE ALTERNATE
SET CONSOLE ON
ENDCASE
IF MH_NdxL
USE
ENDIF
SELE A
RETURN
*%%ENDIF
*%%IF,LAB
*%%DOCUMENT,LAB,Label Module
PROCEDURE LAB
STORE .N. TO MH_Prt
STORE .Y. TO MH_Con
STORE .N. TO MH_Disk
STORE " " TO MH_Frm
STORE ".T."+SPACE(73) TO MH_Cri
STORE " " TO MH_DFname
IF "DB3+"$DBVersion
*%%IF,3PLUS
CALL DPOUT
*%%ENDIF
ELSE
CLEAR
DO DPO
ENDIF
@5,22 SAY MH_Prt
@6,22 SAY MH_Con
@7,22 SAY MH_Disk
@7,42 SAY MH_DFname
@9,15 SAY MH_Frm
DO WHILE .T.
@5,22 GET MH_Prt PICTURE "L"
@6,22 GET MH_Con PICTURE "L"
@7,22 GET MH_Disk PICTURE "L"
@7,42 GET MH_Dfname PICTURE "!!!!!!!!!!!!!!"
@9,15 GET MH_Frm PICTURE "!!!!!!!!"
READ
@24,0
IF MH_Prt .AND. MH_Con
@24,0 SAY "You must only specify one output device"
LOOP
ENDIF
IF MH_Prt .AND. MH_Disk
@24,0 SAY "You must only specify one output device"
LOOP
ENDIF
IF MH_Con .AND. MH_Disk
@24,0 SAY "You must only specify one output device"
LOOP
ENDIF
IF MH_Disk .AND. MH_Dfname = " "
@24,0 SAY "You must specify a disk file name"
LOOP
ENDIF
IF MH_Frm = " "
@24,0 SAY "You must enter a sort name or 'NOSORT'"
LOOP
ENDIF
EXIT
ENDDO
IF MH_Frm = "NOSORT "
STORE .F. TO MH_NdxL
ELSE
IF .NOT.(FILE("DPSORT.DBF") .AND. FILE("DPSORT."+IndxExt))
*%%IF,PRG
DO WAI WITH 24,0,"DPSORT files not found. "
*%%ENDIF
RETURN
ENDIF
SELE I
USE DPSORT INDEX DPSORT
SEEK MH_Frm
IF EOF()
*%%IF,PRG
DO Wai WITH 24,0,"Sort name not on selection file (DPSORT.DBF). "
*%%ENDIF
SELE A
RETURN
ENDIF
STORE SORTCRI TO MH_Cri
STORE SORTNDX TO MH_NDX
STORE SORTFRM TO MH_FRM
STORE .F. TO MH_NdxL
MH_Srt="*"
SortOk=.F.
DO SortChk WITH MH_Srt, MH_NdxL, SortOk
IF .NOT. SortOk
*%%IF,PRG
DO WAI WITH 24,0,"Unknown Sort Field, or Field Type not C,D,N. "
*%%ENDIF
RETURN
ENDIF
ENDIF
@16,13 GET MH_Frm
@19,2 GET MH_Cri
READ
DO WHILE LEN(TRIM(MH_Frm)) = 0
@24,0 SAY "You must specify a form for REPORTs and LABELS"
@16,13 GET MH_Frm
READ
ENDDO
@24,0
DO WHILE IIF(Clipper,.F.,TYPE(MH_Cri)<>"L")
@24,0 SAY "Criteria NOT a legal expression"
@19,2 GET MH_Cri
READ
ENDDO
@24,0
STORE TRIM(MH_Frm)+".LBL" TO MH_work
IF .NOT. FILE(MH_Work)
*%%IF,PRG
DO WAI WITH 24,0,"LABEL FORM "+TRIM(MH_Frm)+" not found. "
*%%ENDIF
RETURN
ENDIF
IF MH_NdxL
@24,0
@24,0 SAY "SELECTING/SORTING DATA! PLEASE WAIT . . . "
IF MH_Cri=SPACE(76)
STORE ".T."+SPACE(73) TO MH_Cri
ENDIF
IF RECCOUNT()>1
SORT TO &MH_NDX ON &MH_SRT FOR &MH_Cri
ELSE
COPY TO &MH_NDX FOR &MH_Cri
ENDIF
SELE J
USE &MH_NDX
ELSE
@24,0
@24,0 SAY "Using Unsorted File"
ENDIF
@24,0
@24,0 SAY "PRODUCING OUTPUT. PLEASE WAIT . . . "
DO CASE
CASE MH_Con
LABEL FORM &MH_Frm FOR &MH_Cri
CASE MH_Prt
SET CONSOLE OFF
LABEL FORM &MH_Frm TO PRINT FOR &MH_Cri
SET CONSOLE ON
CASE MH_Disk
SET CONSOLE OFF
SET ALTERNATE TO &MH_Dfname
SET ALTERNATE ON
LABEL FORM &MH_Frm FOR &MH_Cri
SET ALTERNATE OFF
CLOSE ALTERNATE
SET CONSOLE ON
ENDCASE
IF MH_NdxL
USE
ENDIF
SELE A
RETURN
*%%ENDIF
*%%IF,MM
*%%DOCUMENT,MM,Mail Merge module
PROCEDURE MM
STORE .N. TO MH_Prt
STORE .N. TO MH_Con
STORE .Y. TO MH_Disk
STORE "MMWORK " TO MH_DFname
STORE " " TO MH_Frm
STORE "WORDSTAR" TO MH_WP
STORE ".T."+SPACE(73) TO MH_Cri
IF "DB3+"$DBVersion
*%%IF,3PLUS
CALL DPOUT
*%%ENDIF
ELSE
CLEAR
DO DPO
ENDIF
@11,2 SAY "Word Processor:"
@7,22 SAY MH_Disk
@7,42 SAY MH_DFname
@9,15 SAY MH_Frm
@11,19 SAY MH_WP
DO WHILE .T.
@7,42 GET MH_Dfname PICTURE "!!!!!!!!!!"
@9,15 GET MH_Frm PICTURE "!!!!!!!!"
@11,19 GET MH_WP PICTURE "!!!!!!!!"
READ
@24,0
IF MH_Disk .AND. MH_Dfname = " "
@24,0 SAY "You must enter a disk filename"
LOOP
ENDIF
IF MH_Frm = " "
@24,0 SAY "You must enter a sort form or 'NOSORT'"
LOOP
ENDIF
IF .NOT.(MH_WP = "WORDSTAR" .OR. MH_WP = "MSWORD ")
@24,0 SAY "Current WP formats are: WORDSTAR, MSWORD"
LOOP
ENDIF
EXIT
ENDDO
IF MH_Frm = "NOSORT "
STORE .F. TO MH_NdxL
ELSE
IF .NOT. (FILE("DPSORT.DBF") .AND. FILE("DPSORT."+IndxExt))
*%%IF,PRG
DO WAI WITH 24,0,"DPSORT files not found. "
*%%ENDIF
RETURN
ENDIF
SELE I
USE DPSORT INDEX DPSORT
SEEK MH_Frm
IF EOF()
*%%IF,PRG
DO WAI WITH 24,0,"Sort name not on selection file (DPSORT.DBF). "
*%%ENDIF
USE
SELE A
RETURN
ENDIF
STORE SORTCRI TO MH_Cri
STORE SORTNDX TO MH_NDX
STORE .F. TO MH_NdxL
MH_Srt="*"
SortOk=.F.
DO SortChk WITH MH_Srt, MH_NdxL, SortOk
IF .NOT. SortOk
*%%IF,PRG
DO WAI WITH 24,0,"Unknown Sort Field, or Field Type not C,D,N. "
*%%ENDIF
RETURN
ENDIF
ENDIF
@24,0
@19,2 GET MH_Cri
READ
DO WHILE IIF(Clipper,.F.,TYPE(MH_Cri)<>"L")
@24,0 SAY "Criteria NOT a legal expression"
@19,2 GET MH_Cri
READ
ENDDO
@24,0
IF MH_NdxL
@24,0
@24,0 SAY "SELECTING/SORTING DATA! PLEASE WAIT . . . "
IF MH_Cri=SPACE(76)
STORE ".T."+SPACE(73) TO MH_Cri
ENDIF
IF RECCOUNT()>1
SORT TO &MH_NDX ON &MH_SRT FOR &MH_Cri
ELSE
COPY TO &MH_NDX FOR &MH_Cri
ENDIF
SELE J
USE &MH_NDX
ELSE
@24,0
@24,0 SAY "Using Unsorted File"
ENDIF
@24,0
@24,0 SAY "PRODUCING OUTPUT. PLEASE WAIT . . . "
IF (.NOT. MH_NdxL) .AND. (LEN(TRIM(MH_Cri)) <> 0)
LOCATE FOR &MH_Cri
ENDIF
IF EOF()
*%%IF,PRG
DO WAI WITH 24,0,"No records meet criteria. "
*%%ENDIF
SELE A
RETURN
ENDIF
*
* Turn on output device
*
SET CONSOLE OFF
STORE TRIM(MH_Dfname)+".DOC" TO MH_Ofn
SET ALTERNATE TO &MH_Ofn
SET ALTERNATE ON
*
* Output field header
*
DO CASE
CASE MH_WP = "WORDSTAR"
?".OP"
?".DF "+MH_DFNAME+".DAT"
?".RV "
*%%MMFIELDS
?
SET ALTERNATE OFF
CLOSE ALTERNATE
STORE TRIM(MH_Dfname)+".DAT" TO MH_Ofn
SET ALTERNATE TO &MH_Ofn
SET ALTERNATE ON
CASE MH_WP = "MSWORD "
?
*%%MMFIELDS
ENDCASE
*
* Output Selected data
*
DO WHILE .NOT. EOF()
DO CASE
CASE (MH_WP = "WORDSTAR") .OR. (MH_WP = "MSWORD ")
? ""
*%%MMDATA
ENDCASE
IF MH_NdxL .OR. (LEN(TRIM(MH_Cri)) = 0)
SKIP
ELSE
CONTINUE
ENDIF
ENDDO
*
* Finish output
*
SET ALTERNATE OFF
CLOSE ALTERNATE
SET CONSOLE ON
IF MH_NdxL
USE
ENDIF
SELE A
RETURN
*%%ENDIF
*%%IF,VAL
*%%DOCUMENT,VAL,Validate data module
PROCEDURE VAL
*%%VAL
RETURN
*%%ENDIF
*%%IF,HLP
*%%DOCUMENT,HLP,Give general information
PROCEDURE HLP
PARAMETERS What
*%%HLP
RETURN
*%%ENDIF
*%%IF,PRG
*%%DOCUMENT,IND,Build/re-build Index module
PROCEDURE IND
PARAMETERS DataFile, IndxFile, IndxExpr, action
IF .NOT. Indexed
RETURN
ENDIF
USE &DataFile
@24,0
IF .NOT. File(IndxFile)
@24,0 SAY "Please wait, file is being Indexed . . . "
INDEX ON &IndxExpr TO &IndxFile
ELSE
IF action="REINDEX"
@24,0 SAY "Please wait, file is being Re-Indexed . . . "
REINDEX
ENDIF
ENDIF
SET INDEX TO &IndxFile
@24,0
RETURN
*%%ENDIF
*%%IF,PRG*(SRT+RPT+LAB+MM)
*%%DOCUMENT,SCH,Validate/Verify Sort Fields for Sort routine
PROCEDURE SortChk
PARAMETERS MH_Srt, MH_NdxL, SortOK
PRIVATE sfld, sortf, sorto, SVar
SortOK=.T.
SELE I
USE DPSORT INDEX DPSORT
MH_Srt=""
sfld=1
DO WHILE sfld<=10
sortf="SORTF"+LTRIM(STR(sfld))
sorto="SORTO"+LTRIM(STR(sfld))
SVar=TRIM(&sortf)
IF &SORTF <> " "
SELE A
IF .NOT. TYPE(SVar)$"CDN"
SELE I
USE
SELE A
SortOK=.F.
RETURN
ENDIF
SELE I
IF LEN(MH_Srt)=0
STORE TRIM(&SORTF)+"/"+&SORTO TO MH_Srt
ELSE
STORE MH_Srt+", "+TRIM(&SORTF)+"/"+&SORTO TO MH_Srt
ENDIF
STORE .T. TO MH_NdxL
ENDIF
sfld=sfld+1
ENDDO
USE
SELE A
RETURN
*%%ENDIF
*%%IF,~(3PLUS)
*%%MAKEDB3
*%%ENDIF
*%%CLOSE
*%%IF,SRT*PRG
*%%OPENDIRECT,DPSORT
*%%DOCUMENT,PRG,Main Menu Program
* database: DPSORT
PRIVATE MH_Function, MH_Loop
SET STATUS OFF
SET TALK OFF
SET ECHO OFF
SET BELL OFF
SET HEADING OFF
SET SAFETY OFF
SET DEVICE TO SCREEN
SET PROCEDURE TO DPSORT
SELECT I
DO IND_ WITH "ENSURE"
USE DPSORT INDEX DPSORT
SET FILTER TO
DO PUB_
STORE .T. TO MH_Loop
DO WHILE MH_Loop
DO CASE
CASE "CLIPPER"$DBVersion
*%%IF,CLIPPER
CLEAR
DO DPMMSRTS
*%%ENDIF
CASE "DB3+"$DBVersion
*%%IF,3PLUS
CALL DPMMSORT
*%%ENDIF
CASE "DB3"$DBVersion
*%%IF,DB3
CLEAR
DO DPMMSRTS
*%%ENDIF
ENDCASE
STORE " " TO MH_Function
@ 24,0
@ 2,3 SAY DTOC(DATE())
@ 2,69 SAY Time()
@ 23,47 SAY "Choice:"
@ 23,55 GET MH_Function PICT "!"
READ
DO CASE
CASE UPPER(MH_Function)="A"
DO ADD_
LOOP
CASE UPPER(MH_Function)="U"
IF RECCOUNT()=0
DO WAI_ WITH 24, 0, "File empty, request denied."
LOOP
ENDIF
DO UPD_
LOOP
CASE UPPER(MH_Function)="I"
DO IND_ WITH "REINDEX"
LOOP
CASE UPPER(MH_Function)="H"
DO HLP_ WITH 1
LOOP
CASE UPPER(MH_Function)="P"
@24,0
@24,0 SAY "Delete all marked records"
PRIVATE MH_Ans
STORE "N" TO MH_Ans
@24,30 GET MH_Ans PICT "!"
READ
IF MH_Ans="Y"
PACK
ENDIF
RELEASE MH_Ans
LOOP
CASE UPPER(MH_Function)="Q"
DO REL_
CLOSE DATABASES
CLEAR
QUIT
CASE UPPER(MH_Function)="D"
DO REL_
CLOSE DATABASES
RETURN
CASE UPPER(mh_function)="R"
IF Clipper
DO WAI_ WITH 24, 0, "Report Create/Modify not implemented by Clipper."
LOOP
ENDIF
STORE " " TO MH_Name
@24,0
@24,0 SAY "Report Name:"
@24,14 GET MH_Name
READ
IF MH_Name <> " "
SELE A
*%%IF,~(CLIPPER)
MODI REPORT &MH_Name
*%%ENDIF
SELE I
ENDIF
LOOP
CASE UPPER(mh_function)="L"
IF Clipper
DO WAI_ WITH 24, 0, "Label Create/Modify not implemented by Clipper."
LOOP
ENDIF
STORE " " TO MH_Name
@24,0
@24,0 SAY "Label Name:"
@24,14 GET MH_Name
READ
IF MH_Name <> " "
SELE A
*%%IF,~(CLIPPER)
MODI LABEL &MH_Name
*%%ENDIF
SELE I
ENDIF
LOOP
ENDCASE
ENDDO
RETURN
*%%DOCUMENT,IND,Build/ReBuild Index
PROCEDURE IND_
PARAMETERS action
SELE I
USE DPSORT
IF (.NOT. FILE("DPSORT"+IIF(Clipper,".NTX",".NDX"))) .OR. action="REINDEX"
@24,0
@24,0 SAY "Please wait, file is being Indexed"
INDEX ON SORTNAM TO DPSORT
@24,0
ENDIF
SET INDEX TO DPSORT
RETURN
*%%DOCUMENT,FMT,Screen Format file
PROCEDURE FMT_
PARA Action
IF action="A"
@4,13 GET MA_SORTNAM PICTURE "!!!!!!!!"
ENDIF
@4,48 GET MA_SORTNDX PICTURE "!!!!!!!!"
@4,70 GET MA_SORTFRM PICTURE "!!!!!!!!"
@5,15 GET MA_SORTDES
@8,2 GET MA_SORTCRI
RETURN
*%%DOCUMENT,PUB,Define Public Fields
PROCEDURE PUB_
PUBLIC MA_SORTNAM
PUBLIC MA_SORTNDX
PUBLIC MA_SORTFRM
PUBLIC MA_SORTDES
PUBLIC MA_SORTCRI
PUBLIC MA_SORTF1
PUBLIC MA_SORTO1
PUBLIC MA_SORTF2
PUBLIC MA_SORTO2
PUBLIC MA_SORTF3
PUBLIC MA_SORTO3
PUBLIC MA_SORTF4
PUBLIC MA_SORTO4
PUBLIC MA_SORTF5
PUBLIC MA_SORTO5
PUBLIC MA_SORTF6
PUBLIC MA_SORTO6
PUBLIC MA_SORTF7
PUBLIC MA_SORTO7
PUBLIC MA_SORTF8
PUBLIC MA_SORTO8
PUBLIC MA_SORTF9
PUBLIC MA_SORTO9
PUBLIC MA_SORTF10
PUBLIC MA_SORTO10
RETURN
*%%DOCUMENT,CAL,Calculate and Display Calculated Fields
PROCEDURE CAL_
RETURN
*%%DOCUMENT,INT,Initialize Memory fields from Init or empty
PROCEDURE INT_
STORE SPACE(8) TO MA_SORTNAM
STORE "SORTWORK" TO MA_SORTNDX
STORE SPACE(8) TO MA_SORTFRM
STORE SPACE(63) TO MA_SORTDES
STORE ".T."+SPACE(LEN(DPSORT->SORTCRI)-1) TO MA_SORTCRI
STORE SPACE(7) TO MA_SORTF1
STORE "A" TO MA_SORTO1
STORE SPACE(7) TO MA_SORTF2
STORE "A" TO MA_SORTO2
STORE SPACE(7) TO MA_SORTF3
STORE "A" TO MA_SORTO3
STORE SPACE(7) TO MA_SORTF4
STORE "A" TO MA_SORTO4
STORE SPACE(7) TO MA_SORTF5
STORE "A" TO MA_SORTO5
STORE SPACE(7) TO MA_SORTF6
STORE "A" TO MA_SORTO6
STORE SPACE(7) TO MA_SORTF7
STORE "A" TO MA_SORTO7
STORE SPACE(7) TO MA_SORTF8
STORE "A" TO MA_SORTO8
STORE SPACE(7) TO MA_SORTF9
STORE "A" TO MA_SORTO9
STORE SPACE(7) TO MA_SORTF10
STORE "A" TO MA_SORTO10
RETURN
*%%DOCUMENT,STO,Store file Fields to memory variables
PROCEDURE STO_
STORE DPSORT -> SORTNAM to MA_SORTNAM
STORE DPSORT -> SORTNDX to MA_SORTNDX
STORE DPSORT -> SORTFRM to MA_SORTFRM
STORE DPSORT -> SORTDES to MA_SORTDES
STORE DPSORT -> SORTCRI to MA_SORTCRI
STORE DPSORT -> SORTF1 to MA_SORTF1
STORE DPSORT -> SORTO1 to MA_SORTO1
STORE DPSORT -> SORTF2 to MA_SORTF2
STORE DPSORT -> SORTO2 to MA_SORTO2
STORE DPSORT -> SORTF3 to MA_SORTF3
STORE DPSORT -> SORTO3 to MA_SORTO3
STORE DPSORT -> SORTF4 to MA_SORTF4
STORE DPSORT -> SORTO4 to MA_SORTO4
STORE DPSORT -> SORTF5 to MA_SORTF5
STORE DPSORT -> SORTO5 to MA_SORTO5
STORE DPSORT -> SORTF6 to MA_SORTF6
STORE DPSORT -> SORTO6 to MA_SORTO6
STORE DPSORT -> SORTF7 to MA_SORTF7
STORE DPSORT -> SORTO7 to MA_SORTO7
STORE DPSORT -> SORTF8 to MA_SORTF8
STORE DPSORT -> SORTO8 to MA_SORTO8
STORE DPSORT -> SORTF9 to MA_SORTF9
STORE DPSORT -> SORTO9 to MA_SORTO9
STORE DPSORT -> SORTF10 to MA_SORTF10
STORE DPSORT -> SORTO10 to MA_SORTO10
RETURN
*%%DOCUMENT,REP,Replace file Fields with memory variables
PROCEDURE REP_
REPLACE DPSORT -> SORTNAM WITH MA_SORTNAM
REPLACE DPSORT -> SORTNDX WITH MA_SORTNDX
REPLACE DPSORT -> SORTFRM WITH MA_SORTFRM
REPLACE DPSORT -> SORTDES WITH MA_SORTDES
REPLACE DPSORT -> SORTCRI WITH MA_SORTCRI
REPLACE DPSORT -> SORTF1 WITH MA_SORTF1
REPLACE DPSORT -> SORTO1 WITH MA_SORTO1
REPLACE DPSORT -> SORTF2 WITH MA_SORTF2
REPLACE DPSORT -> SORTO2 WITH MA_SORTO2
REPLACE DPSORT -> SORTF3 WITH MA_SORTF3
REPLACE DPSORT -> SORTO3 WITH MA_SORTO3
REPLACE DPSORT -> SORTF4 WITH MA_SORTF4
REPLACE DPSORT -> SORTO4 WITH MA_SORTO4
REPLACE DPSORT -> SORTF5 WITH MA_SORTF5
REPLACE DPSORT -> SORTO5 WITH MA_SORTO5
REPLACE DPSORT -> SORTF6 WITH MA_SORTF6
REPLACE DPSORT -> SORTO6 WITH MA_SORTO6
REPLACE DPSORT -> SORTF7 WITH MA_SORTF7
REPLACE DPSORT -> SORTO7 WITH MA_SORTO7
REPLACE DPSORT -> SORTF8 WITH MA_SORTF8
REPLACE DPSORT -> SORTO8 WITH MA_SORTO8
REPLACE DPSORT -> SORTF9 WITH MA_SORTF9
REPLACE DPSORT -> SORTO9 WITH MA_SORTO9
REPLACE DPSORT -> SORTF10 WITH MA_SORTF10
REPLACE DPSORT -> SORTO10 WITH MA_SORTO10
RETURN
*%%DOCUMENT,REL,Release Memory variables
PROCEDURE REL_
RELEASE MA_SORTNAM
RELEASE MA_SORTNDX
RELEASE MA_SORTFRM
RELEASE MA_SORTDES
RELEASE MA_SORTCRI
RELEASE MA_SORTF1
RELEASE MA_SORTO1
RELEASE MA_SORTF2
RELEASE MA_SORTO2
RELEASE MA_SORTF3
RELEASE MA_SORTO3
RELEASE MA_SORTF4
RELEASE MA_SORTO4
RELEASE MA_SORTF5
RELEASE MA_SORTO5
RELEASE MA_SORTF6
RELEASE MA_SORTO6
RELEASE MA_SORTF7
RELEASE MA_SORTO7
RELEASE MA_SORTF8
RELEASE MA_SORTO8
RELEASE MA_SORTF9
RELEASE MA_SORTO9
RELEASE MA_SORTF10
RELEASE MA_SORTO10
RETURN
*%%DOCUMENT,ADD,Add new records to file
PROCEDURE ADD_
PRIVATE MH_Loop, MH_Wait
STORE .T. TO MH_Loop
STORE " " TO MH_Wait
DO CASE
CASE "CLIPPER"$DBVersion
*%%IF,CLIPPER
CLEAR
DO DPSORTS
*%%ENDIF
CASE "DB3+"$DBVersion
*%%IF,3PLUS
CALL DPSORT
*%%ENDIF
CASE "DB3"$DBVersion
*%%IF,DB3
CLEAR
DO DPSORTS
*%%ENDIF
ENDCASE
DO WHILE MH_Loop
DO INT_
DO FMT_ WITH "A"
@24,0
@24,0 SAY "Press Ctrl-W without entering data to exit"
READ
IF LEN(TRIM(MA_SORTNAM)) <> 0
SEEK MA_SORTNAM
@ 24,0
DO WHILE .NOT. EOF()
?? CHR(7)
@24,0 SAY "Sort Name is a duplicate; change it to allow the addition."
@04,13 GET MA_SORTNAM PICTURE "!!!!!!!!"
READ
SEEK MA_SORTNAM
ENDDO
@ 24,0
DO VAL_
APPEND BLANK
DO REP_
DO CAL_
DO WAI_ WITH 24, 0, ""
ELSE
STORE .F. TO MH_Loop
ENDIF
ENDDO
RELEASE MH_Loop,MH_Wait
RETURN
*%%DOCUMENT,UPD,Search Update Edit Find Print Examine file
PROCEDURE UPD_
PRIVATE MH_Loop, MH_Function, MH_Answer
STORE .T. TO MH_Loop
STORE "N" TO MH_Function
STORE "N" TO MH_Answer
STORE SPACE(70) TO MH_Filt
STORE "Next,Previous,Top,Bottom,Quit,Help,Delete,Edit,More " TO MH_Menu1
STORE "Find,Set filter,pRint,More " TO MH_Menu2
STORE MH_Menu1 TO MH_Menu
DO CASE
CASE "CLIPPER"$DBVersion
*%%IF,CLIPPER
CLEAR
DO DPSORTS
*%%ENDIF
CASE "DB3+"$DBVersion
*%%IF,3PLUS
CALL DPSORT
*%%ENDIF
CASE "DB3"$DBVersion
*%%IF,DB3
CLEAR
DO DPSORTS
*%%ENDIF
ENDCASE
DO WHILE MH_Loop
DO STO_
DO DIS_
DO CAL_
@24,0 SAY MH_Menu
@24,53 GET MH_Function PICT "!"
IF LEN(TRIM(MH_Filt)) = 0
@24,55 SAY " "
ELSE
@24,55 SAY "FILT"
ENDIF
IF Deleted()
@24,60 SAY "DEL"
ELSE
@24,60 SAY " "
ENDIF
@24,65 SAY Ltrim(Str(RECNO()))+"/"+Ltrim(STR(RECCOUNT()))+" "
READ
DO CASE
CASE UPPER(MH_Function) = "N"
IF .NOT. EOF()
Skip 1
IF EOF()
GO BOTT
ENDIF
ENDIF
LOOP
CASE UPPER(MH_Function) = "P"
IF .NOT. BOF()
SKIP -1
IF BOF()
GO TOP
ENDIF
ENDIF
LOOP
CASE UPPER(MH_Function) = "E"
DO STO_
DO FMT_ WITH "E"
READ
IF READKEY()=12 .OR. READKEY()=268
LOOP
ENDIF
DO VAL_
DO CAL_
DO REP_
LOOP
CASE UPPER(MH_Function) = "T"
GOTO TOP
LOOP
CASE UPPER(MH_Function) = "B"
GOTO BOTTOM
LOOP
CASE UPPER(MH_Function) = "D"
STORE "N" TO MH_Answer
@24,0
IF DELETED()
@24,0 SAY "Recall this record?"
ELSE
@24,0 SAY "Delete this record?"
ENDIF
@24,22 GET MH_Answer
READ
IF UPPER(MH_Answer) = "Y"
IF DELETED()
RECALL
ELSE
DELETE
ENDIF
ENDIF
LOOP
CASE UPPER(MH_Function) = "S"
STORE "N" TO MH_Answer
STORE MH_Filt TO MH_FiltH
@24,0
@24,0 SAY "FILTER: "
@24,9 GET MH_Filt
READ
@24,0
IF MH_Filt <> MH_FiltH
IF LEN(TRIM(MH_Filt)) <> 0
IF IIF(Clipper,.F.,TYPE(MH_Filt)<>"L")
DO WAI_ WITH 24, 0, "Filter expression defective, not usable."
MH_Filt=MH_FiltH
LOOP
ENDIF
SET FILTER TO &MH_Filt
ELSE
SET FILTER TO .T.
ENDIF
GO TOP
IF EOF()
DO WAI_ WITH 24, 0, "Nothing matches filter!"
ENDIF
ENDIF
LOOP
CASE UPPER(MH_Function) = "F"
DO FND_
LOOP
CASE UPPER(MH_Function) = "M"
IF MH_Menu1 = MH_Menu
STORE MH_Menu2 TO MH_Menu
ELSE
STORE MH_Menu1 TO MH_Menu
ENDIF
LOOP
CASE UPPER(MH_Function) = "Q"
STORE .F. TO MH_LOOP
LOOP
CASE UPPER(MH_Function) = "R"
DO WAI_ WITH 24,0,"MAKE SURE PRINTER IS ON LINE!!!"
DO CASE
CASE "DB3+"$DBVersion
*%%IF,3PLUS
ON ERROR DO WAI_ WITH 24,0,"Fix PRINTER !!!"
*%%ENDIF
CASE "CLIPPER"$DBVersion
*%%IF,CLIPPER
DO WHILE .NOT. ISPRINTER()
?? CHR(7)
DO WAI_ WITH 24,0,"Fix PRINTER !!!"
ENDDO
*%%ENDIF
ENDCASE
SET DEVICE TO PRINT
DO DIS_
SET DEVICE TO SCREEN
*%%IF,3PLUS
IF "DB3+"$DBVersion
ON ERROR
ENDIF
*%%ENDIF
LOOP
CASE UPPER(MH_Function)="H"
DO HLP_ WITH 2
DO CASE
CASE "CLIPPER"$DBVersion
*%%IF,CLIPPER
CLEAR
DO DPSORTS
*%%ENDIF
CASE "DB3+"$DBVersion
*%%IF,3PLUS
CALL DPSORT
*%%ENDIF
CASE "DB3"$DBVersion
*%%IF,DB3
CLEAR
DO DPSORTS
*%%ENDIF
ENDCASE
LOOP
ENDCASE
STORE "N" TO MH_Function
ENDDO
SET FILTER TO .T.
RELEASE MH_Function,MH_Loop,MH_Answer
RETURN
*%%DOCUMENT,DIS,Display-only Format file
PROCEDURE DIS_
@4,13 SAY MA_SORTNAM PICTURE "!!!!!!!!"
@4,48 SAY MA_SORTNDX PICTURE "!!!!!!!!"
@4,70 SAY MA_SORTFRM PICTURE "!!!!!!!!"
@5,15 SAY MA_SORTDES
@8,2 SAY MA_SORTCRI
@13,30 SAY MA_SORTF1 PICTURE "!!!!!!!"
@13,46 SAY MA_SORTO1 PICTURE "!"
@14,30 SAY MA_SORTF2 PICTURE "!!!!!!!"
@14,46 SAY MA_SORTO2 PICTURE "!"
@15,30 SAY MA_SORTF3 PICTURE "!!!!!!!"
@15,46 SAY MA_SORTO3 PICTURE "!"
@16,30 SAY MA_SORTF4 PICTURE "!!!!!!!"
@16,46 SAY MA_SORTO4 PICTURE "!"
@17,30 SAY MA_SORTF5 PICTURE "!!!!!!!"
@17,46 SAY MA_SORTO5 PICTURE "!"
@18,30 SAY MA_SORTF6 PICTURE "!!!!!!!"
@18,46 SAY MA_SORTO6 PICTURE "!"
@19,30 SAY MA_SORTF7 PICTURE "!!!!!!!"
@19,46 SAY MA_SORTO7 PICTURE "!"
@20,30 SAY MA_SORTF8 PICTURE "!!!!!!!"
@20,46 SAY MA_SORTO8 PICTURE "!"
@21,30 SAY MA_SORTF9 PICTURE "!!!!!!!"
@21,46 SAY MA_SORTO9 PICTURE "!"
@22,30 SAY MA_SORTF10 PICTURE "!!!!!!!"
@22,46 SAY MA_SORTO10 PICTURE "!"
RETURN
*%%DOCUMENT,FND,Find record by key routine
PROCEDURE FND_
PRIVATE MH_Find,MH_Answer,MH_Rec
STORE " " TO MH_Find
STORE " " TO MH_Answer
STORE 0 TO MH_Rec
@4,13 GET MA_SORTNAM PICTURE "!!!!!!!!"
@4,48 SAY MA_SORTNDX PICTURE "!!!!!!!!"
@4,70 SAY MA_SORTFRM PICTURE "!!!!!!!!"
@5,15 SAY MA_SORTDES
@8,2 SAY MA_SORTCRI
@13,30 SAY MA_SORTF1 PICTURE "!!!!!!!"
@13,46 SAY MA_SORTO1 PICTURE "!"
@14,30 SAY MA_SORTF2 PICTURE "!!!!!!!"
@14,46 SAY MA_SORTO2 PICTURE "!"
@15,30 SAY MA_SORTF3 PICTURE "!!!!!!!"
@15,46 SAY MA_SORTO3 PICTURE "!"
@16,30 SAY MA_SORTF4 PICTURE "!!!!!!!"
@16,46 SAY MA_SORTO4 PICTURE "!"
@17,30 SAY MA_SORTF5 PICTURE "!!!!!!!"
@17,46 SAY MA_SORTO5 PICTURE "!"
@18,30 SAY MA_SORTF6 PICTURE "!!!!!!!"
@18,46 SAY MA_SORTO6 PICTURE "!"
@19,30 SAY MA_SORTF7 PICTURE "!!!!!!!"
@19,46 SAY MA_SORTO7 PICTURE "!"
@20,30 SAY MA_SORTF8 PICTURE "!!!!!!!"
@20,46 SAY MA_SORTO8 PICTURE "!"
@21,30 SAY MA_SORTF9 PICTURE "!!!!!!!"
@21,46 SAY MA_SORTO9 PICTURE "!"
@22,30 SAY MA_SORTF10 PICTURE "!!!!!!!"
@22,46 SAY MA_SORTO10 PICTURE "!"
@24,0
@24,0 SAY "Enter data to search for in open fields"
READ
IF LEN(TRIM(MA_SORTNAM)) <> 0
STORE MA_SORTNAM TO MH_Find
STORE RECNO() TO MH_Rec
FIND &MH_Find
IF EOF()
GOTO MH_Rec
DO WAI_ WITH 24, 0, "Record NOT Found! "
ELSE
DO WAI_ WITH 24, 0, "Record Found! "
ENDIF
ENDIF
RELEASE MH_Find,MH_Answer,MH_Rec
@24,0
RETURN
*%%DOCUMENT,VAL,Validate Data module
PROCEDURE VAL_
@ 24,0
SELE A
DO WHILE IIF(Clipper,.F.,TYPE(MA_SORTCRI)<>"L")
?? CHR(7)
@ 24,0 SAY "Sort Criteria defective; repair the expression"
@ 8,2 GET MA_SORTCRI
READ
ENDDO
@ 24,0
SELE I
IF .NOT. CLIPPER
SET ESCA OFF
ENDIF
ofs=12
sel=1
fc=10
key=0
nums="1 2 3 4 5 6 7 8 9 10"
DO WHIL key<>27
FVar="MA_SORTF"+SUBS(nums,(sel-1)*2+1,2)
OVar="MA_SORTO"+SUBS(nums,(sel-1)*2+1,2)
@ 24,0
@ 24,0 SAY "Up, Down arrows change fields; <RETURN> = access; <Esc> = quit"
@ sel+ofs,29 SAY "@"
DO GetKey WITH CHR(5)+CHR(24)+CHR(13)+CHR(27),key
@sel+ofs,29 SAY " "
DO CASE
CASE key=5
sel=sel-1
CASE key=24
sel=sel+1
CASE key=13
DO SDF WITH sel+ofs,30,46,&Fvar,&OVar
ENDC
sel=IIF(sel>fc,1,sel)
sel=IIF(sel<1,fc,sel)
ENDD
SET ESCA ON
@ 24,0
RETU
*%%DOCUMENT,SDF,Scan and Select; (or Enter) Sort Field Names
PROCEDURE SDF
PARA Ln, Cl, Cl2, Fld, Ord
PRIV key
fld=fld+SPACE(7-LEN(fld))
Ord=Ord+SPACE(1-LEN(Ord))
key=0
DO WHILE .T.
@ Ln,Cl SAY Fld
@ Ln,Cl2 SAY Ord
@ 24,0
@ 24,0 SAY "<SPACE> = Field Scan; <RETURN> = Field Edit <Esc> = done field"
DO GetKey WITH " "+CHR(13)+CHR(27),key
@ 24,0
DO CASE
CASE key=27
RETURN
CASE key=13
@ 24,0 SAY "Edit the fieldname; <Esc> restores original"
fno=0
fldh=fld
DO WHIL fno=0
@ Ln,Cl GET fld PICTURE "!!!!!!!"
READ
IF LEN(TRIM(fld))=0
EXIT
ENDIF
IF READKEY()=12.OR.READKEY()=268
fld=fldh
EXIT
ENDIF
@ 24,55 say "CHECKING..."
DO ValidFld WITH fld, fno
@ 24,55
@ 24,55 say IIF(fno>0,"OK","BAD FIELD")
ENDD
@ Ln,Cl SAY Fld
CASE key=32
@ 24,0 SAY "Arrows Scan, <RETURN> selects, <Esc> quits Scan"
STOR 1 TO I,K
sks=CHR(4)+CHR(19)+CHR(13)+CHR(27)
SELE A
DO WHILE LEN(FIELD(I))>0
@ Ln,Cl SAY " "
@ Ln,Cl SAY FIELD(I)
DO GetKey WITH sks,k
DO CASE
CASE k=13
fld=FIELD(I)+SPACE(7-LEN(FIELD(I)))
EXIT
CASE k=19
I=IIF(i>1,i-1,i)
CASE k=4
I=IIF(LEN(FIELD(i+1))=0,i,i+1)
CASE k=27
EXIT
ENDC
ENDDO
SELE dpsort
ENDCASE
IF LEN(TRIM(fld))=0
Ord=" "
ELSE
badord=.T.
@ 24,0
DO WHILE badord
@ 24,0 SAY "Enter 'A' or 'D' for Ascending/Descending Sort Order"
@ Ln,Cl2 GET ord PICTURE "!"
READ
badord=.NOT.(ord$"AD")
ENDDO
@ 24,0
ENDIF
ENDD
RETU
*%%DOCUMENT,INK,Low-level keyboard-reading routine
PROCEDURE GetKey
PARA S,K
k=INKE()
DO WHIL k=0 .AND..NOT. CHR(k)$S
k=INKE()
ENDD
RETU
*%%DOCUMENT,VFD,Ensure valid Sort Field Name entry
PROCEDURE ValidFld
PARA fld, fno
fno=0
i=1
SELE A
SET EXAC ON
DO WHIL LEN(FIEL(I))>0
IF TRIM(fld)=FIEL(I)
fno=I
EXIT
ENDI
I=I+1
ENDD
SELE I
SET EXAC OFF
RETU
*%%DOCUMENT,HLP,Give general help information
PROCEDURE HLP_
PARAMETERS What
DO CASE
CASE What = 1
@0,0 SAY "Sorry, No help available"
CASE What = 2
@0,0 SAY "Sorry, No help available"
OTHERWISE
@0,0 SAY "LOGIC ERROR IN PROGRAM"
ENDCASE
DO WAI_ WITH 24, 0, ""
@0,0
RETURN
*%%DOCUMENT,WAI,Low-level WAIT and Message-display routine
PROCEDURE WAI_
PARA y,x,msg
PRIV dummy
dummy=" "
SET INTE OFF
@Y,X
@Y,X SAY msg+" Press any key to continue..." GET dummy
READ
SET INTE ON
@Y,X
RETU
*%%DOCUMENT,SMM,Sort/select Main Menu screen (used when LOAD/CALL unavailable)
PROCEDURE DPMMSRTS
@ 1,0 SAY "╔══════════════════════════════════════════════════════════════════════════════╗"
@ 2,0 SAY "║ Sort/select definition Menu ║"
@ 3,0 SAY "╟──────────────────────────────────────────────────────────────────────────────╢"
@ 4,0 SAY "║ ║"
@ 5,0 SAY "║ A - Add new definitions ║"
@ 6,0 SAY "║ U - Update, Edit, Scan, Find definitions ║"
@ 7,0 SAY "║ R - Create/Modify a Dbase III Report Form ║"
@ 8,0 SAY "║ ║"
@ 9,0 SAY "║ L - Create/Modify a Dbase III Label Form ║"
@ 10,0 SAY "║ I - Rebuild the Index ║"
@ 11,0 SAY "║ P - Pack the database to remove deleted definitions ║"
@ 12,0 SAY "║ ║"
@ 13,0 SAY "║ ║"
@ 14,0 SAY "║ Q - Quit Program, return to DOS ║"
@ 15,0 SAY "║ D - Return to your application ║"
@ 16,0 SAY "║ ║"
@ 17,0 SAY "║ ║"
@ 18,0 SAY "║ Please choose one of the above options ║"
@ 19,0 SAY "║ ║"
@ 20,0 SAY "╚══════════════════════════════════════════════════════════════════════════════╝"
@ 23,0 SAY " Choice: "
RETURN
*%%DOCUMENT,STS,Sort Definitions screen (used when LOAD/CALL unavailable)
PROCEDURE DPSORTS
@ 1,0 SAY "╔══════════════════════════════════════════════════════════════════════════════╗"
@ 2,0 SAY "║ Sort/Selection Definitions ║"
@ 3,0 SAY "╠══════════════════════════════════════════════════════════════════════════════╣"
@ 4,0 SAY "║ Sort Name: Sorted File Name: Form Name: ║"
@ 5,0 SAY "║ Description: ║"
@ 6,0 SAY "╟──────────────────────────────────────────────────────────────────────────────╢"
@ 7,0 SAY "║ Selection Criteria ║"
@ 8,0 SAY "║ ║"
@ 9,0 SAY "╟──────────────────────────────────────────────────────────────────────────────╢"
@ 10,0 SAY "║ Sort Fields ║"
@ 11,0 SAY "╟──────────────────────────────────────────────────────────────────────────────╢"
@ 12,0 SAY "║ Field Name Order ║"
@ 13,0 SAY "║ 1) ║"
@ 14,0 SAY "║ 2) ║"
@ 15,0 SAY "║ 3) ║"
@ 16,0 SAY "║ 4) ║"
@ 17,0 SAY "║ 5) ║"
@ 18,0 SAY "║ 6) ║"
@ 19,0 SAY "║ 7) ║"
@ 20,0 SAY "║ 8) ║"
@ 21,0 SAY "║ 9) ║"
@ 22,0 SAY "║ 10) ║"
@ 23,0 SAY "╚══════════════════════════════════════════════════════════════════════════════╝"
RETURN
*%%CLOSE
*%%ENDIF